Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Snippets/PNL Libraries/MyLists.p

Text File | 1996-05-29 | 10.2 KB | 415 lines | [TEXT/CWIE]

unit MyLists;

interface

    uses
        Types;

{ Some types have been changed to avoid clashing with the list manager }
    type
        listHead = ^listNode;            { Was listHeadHandle }
        listItem = ^listNode;            { Was listHandle }
        listNode = record
                head: boolean;
                next: listItem;
                prev: listItem;
                this: Handle;
            end;

    var
        listError: boolean;

    procedure CreateList (var l: listHead);
    procedure DestroyList (var l: listHead; dispose: boolean);

    procedure ReturnHead (lh: listHead; var l: listItem);
    (* <a> b c / <a> b c / <a> b c / <a> / <a> / <> *)
    procedure ReturnTail (lh: listHead; var l: listItem);
    (* a b c <> / a b c <> / a b c <> / a b c <> / a <> / a <> / <> *)

    procedure MoveToHead (var l: listItem);
    (* <a> b c / <a> b c / <a> b c / <a> b c / <a> / <a> / <> *)
    procedure MoveToTail (var l: listItem);
    (* a b c <> / a b c <> / a b c <> / a b c <> / a <> / a <> / <> *)
    procedure MoveToNext (var l: listItem);
    (* a <b> c / a b <c> / a b c <> / error / a <> / error / error *)
    procedure MoveToPrev (var l: listItem);
    (* error / <a> b c / a <b> c / a b <c> / error / <a> / error *)

    function FindItem (lh: listHead; it: univ Handle; var l: listItem): boolean;

    procedure AddHead (l: listHead; it: univ Handle);
    (* x <a> b c / x a <b> c / x a b <c> / x a b c <> / x <a> / x a <> / x <>*)
    procedure AddTail (l: listHead; it: univ Handle);
    (* <a> b c x / a <b> c x / a b <c> x / a b c x <> / <a> x / a x <> / x <>*)
    procedure AddBefore (l: listItem; it: univ Handle);
    (* x <a> b c / a x <b> c / a b x <c> / a b c x <> / x <a> / a x <> / x <>*)
    procedure AddAfter (l: listItem; it: univ Handle);
    (* <a> x b c / a <b> x c / a b <c> x / error / <a> x / error / error *)

    procedure DeleteHead (l: listHead; var it: univ Handle);
    (* <?> b c / <b> c / b <c> / b c <> / <?> / <> / error *)
    procedure DeleteTail (l: listHead; var it: univ Handle);
    (* <a> b / a <b> / a b <?> / a b <> / <?> / <> / error *)
    procedure DeletePrev (l: listItem; var it: univ Handle);
    (* error / <b> c / a <c> / a b <> / error / <> / error *)
    procedure DeleteNext (l: listItem; var it: univ Handle);
    (* <a> c / a <b> / error / error / error / error / error *)
    procedure DeleteItem (var l: listItem; var it: univ Handle);
    (* <b> c / a <c> / a b <> / error / <> / error / error *)

    procedure FetchHead (l: listHead; var it: univ Handle);
    (* a / a / a / a / a / a / error  *)
    procedure FetchTail (l: listHead; var it: univ Handle);
    (* c / c / c / c / a / a / error  *)
    procedure FetchNext (l: listItem; var it: univ Handle);
    (* b / c / error / error / error / error / error *)
    procedure FetchPrev (l: listItem; var it: univ Handle);
    (* error / a / b / c / error / a / error *)
    procedure Fetch (l: listItem; var it: univ Handle);
    (* a / b / c / error / a / error / error *)

    function IsHead (l: listItem): boolean;
    (* T / F / F / F / T / F / T *)
    function IsTail (l: listItem): boolean;
    (* F / F / F / T / F / T / T *)
    function IsEmpty (l: listHead): boolean;
    (* F / F / F / F / F / F / T *)

    procedure DisplayList (lh: listHead);
   (* To the Text Screen *)
    procedure ValidateList (lh: listHead; maxlen: longint);
    (* Check the list for validity, maxlen is the maximum valid length *)

implementation

    uses
        Memory;
{ Internal Routines }

    procedure DestroyListPtr (var l: univ listItem);
    begin
{    l^^.next := nil;                These dont do any good }
{    l ^ ^ . prev := nil;            cause DisposHandle }
{    l  ^ ^ . this := nil;            destroys the data }
        DisposePtr(Ptr(l));
        l := nil;
    end;

    procedure CreateListPtr (var l: univ listItem);
    begin
        l := listItem(NewPtr(SizeOf(listNode)));
        if l = nil then begin
            listError := true;
            DebugStr('CreateListPtr Failed!');
        end;
    end;

    procedure MoveToStart (var l: univ listItem);
        var
            tmp: listItem;
    begin
        if not l^.head then begin
            tmp := l;
            repeat
                l := l^.next;
            until (tmp = l) or l^.head;
            if tmp = l then begin
                listError := true;
            end;
        end;
    end;

    procedure InsertBefore (l: univ listItem; var it: univ Handle);
        var
            tmp: listItem;
    begin
        CreateListPtr(tmp);
        if tmp <> nil then begin
            tmp^.head := false;
            tmp^.this := it;
            tmp^.next := l;
            tmp^.prev := l^.prev;
            l^.prev^.next := tmp;
            l^.prev := tmp;
        end;
    end;

    procedure DeleteNode (l: listItem; var it: univ Handle);
    begin
        if l^.head then begin
            listError := true;
        end else begin
            it := l^.this;
            l^.prev^.next := l^.next;
            l^.next^.prev := l^.prev;
            DestroyListPtr(l);
        end;
    end;

    procedure FetchNode (l: listItem; var it: univ Handle);
    begin
        if l^.head then begin
            listError := true;
        end;
        it := l^.this;
    end;

{ External Routines }

    procedure CreateList (var l: listHead);
    begin
        CreateListPtr(l);
        if l <> nil then begin
            l^.head := true;
            l^.next := listItem(l);
            l^.prev := listItem(l);
            l^.this := nil;
        end;
    end;

    procedure DestroyList (var l: listHead; dispose: boolean);
        var
            tmp, tmp2: listItem;
    begin
        tmp := l^.next;
        while tmp <> listItem(l) do begin
            tmp2 := tmp;
            tmp := tmp^.next;
            if dispose then begin
                DisposeHandle(tmp2^.this);
            end;
            DestroyListPtr(tmp2);
        end;
        if dispose then begin
            DisposeHandle(l^.this);
        end;
        DestroyListPtr(l);
    end;

    procedure ReturnHead (lh: listHead; var l: listItem);
    (* <a> b c / <a> b c / <a> b c / <a> / <a> / <> *)
    begin
        l := lh^.next;
    end;

    procedure ReturnTail (lh: listHead; var l: listItem);
    (* a b c <> / a b c <> / a b c <> / a b c <> / a <> / a <> / <> *)
    begin
        l := listItem(lh);
    end;

    function FindItem (lh: listHead; it: univ Handle; var l: listItem): boolean;
    begin
        l := listItem(lh)^.next;
        while (not l^.head) and (it <> l^.this) do begin
            l := l^.next;
        end;
        FindItem := (not l^.head) and (it = l^.this);
    end;

    procedure MoveToHead (var l: listItem);
    (* <a> b c / <a> b c / <a> b c / <a> b c / <a> / <a> / <> *)
    begin
        MoveToStart(l);
        l := l^.next;
    end;

    procedure MoveToTail (var l: listItem);
    (* a b c <> / a b c <> / a b c <> / a b c <> / a <> / a <> / <> *)
    begin
        MoveToStart(l);
    end;

    procedure MoveToNext (var l: listItem);
    (* a <b> c / a b <c> / a b c <> / error / a <> / error / error *)
    begin
        if l^.head then begin
            listError := true;
        end else begin
            l := l^.next;
        end;
    end;

    procedure MoveToPrev (var l: listItem);
    (* error / <a> b c / a <b> c / a b <c> / error / <a> / error *)
    begin
        if l^.prev^.head then begin
            listError := true;
        end else begin
            l := l^.prev;
        end;
    end;

    procedure AddHead (l: listHead; it: univ Handle);
    (* x <a> b c / x a <b> c / x a b <c> / x a b c <> / x <a> / x a <> / x <>*)
    begin
        InsertBefore(l^.next, it);
    end;

    procedure AddTail (l: listHead; it: univ Handle);
    (* <a> b c x / a <b> c x / a b <c> x / a b c x <> / <a> x / a x <> / x <>*)
    begin
        InsertBefore(l, it);
    end;

    procedure AddBefore (l: listItem; it: univ Handle);
    (* x <a> b c / a x <b> c / a b x <c> / a b c x <> / x <a> / a x <> / x <>*)
    begin
        InsertBefore(l, it);
    end;

    procedure AddAfter (l: listItem; it: univ Handle);
    (* <a> x b c / a <b> x c / a b <c> x / error / <a> x / error / error *)
    begin
        if l^.head then begin
            listError := true;
        end else begin
            InsertBefore(l^.next, it);
        end;
    end;

    procedure DeleteHead (l: listHead; var it: univ Handle);
    (* <?> b c / <b> c / b <c> / b c <> / <?> / <> / error *)
    begin
        DeleteNode(l^.next, it);
    end;

    procedure DeleteTail (l: listHead; var it: univ Handle);
    (* <a> b / a <b> / a b <?> / a b <> / <?> / <> / error *)
    begin
        DeleteNode(l^.prev, it);
    end;

    procedure DeletePrev (l: listItem; var it: univ Handle);
    (* error / <b> c / a <c> / a b <> / error / <> / error *)
    begin
        DeleteNode(l^.prev, it);
    end;

    procedure DeleteNext (l: listItem; var it: univ Handle);
    (* <a> c / a <b> / error / error / error / error / error *)
    begin
        if l^.head then begin
            listError := true;
            it := nil;
        end
        else
            DeleteNode(l^.next, it);
    end;

    procedure DeleteItem (var l: listItem; var it: univ Handle);
    (* <b> c / a <c> / a b <> / error / <> / error / error *)
        var
            tmp: listItem;
    begin
        if l^.head then begin
            listError := true;
            it := nil;
        end else begin
            tmp := l^.next;
            DeleteNode(l, it);
            l := tmp;
        end;
    end;

    procedure FetchHead (l: listHead; var it: univ Handle);
    (* a / a / a / a / a / a / error  *)
    begin
        FetchNode(l^.next, it);
    end;

    procedure FetchTail (l: listHead; var it: univ Handle);
    (* c / c / c / c / a / a / error  *)
    begin
        FetchNode(l^.prev, it);
    end;

    procedure FetchNext (l: listItem; var it: univ Handle);
    (* b / c / error / error / error / error / error *)
    begin
        if l^.head then begin
            listError := true;
            it := nil;
        end
        else
            FetchNode(l^.next, it);
    end;

    procedure FetchPrev (l: listItem; var it: univ Handle);
    (* error / a / b / c / error / a / error *)
    begin
        FetchNode(l^.prev, it);
    end;

    procedure Fetch (l: listItem; var it: univ Handle);
    (* a / b / c / error / a / error / error *)
    begin
        FetchNode(l, it);
    end;

    function IsHead (l: listItem): boolean;
    (* T / F / F / F / T / F / T *)
    begin
        IsHead := l^.prev^.head;
    end;

    function IsTail (l: listItem): boolean;
    (* F / F / F / T / F / T / T *)
    begin
        IsTail := l^.head;
    end;

    function IsEmpty (l: listHead): boolean;
    (* F / F / F / F / F / F / T *)
    begin
        IsEmpty := l^.next = listItem(l);
    end;

    procedure DisplayList (lh: listHead);
        var
            l: listItem;
            hhhh: Handle;
    begin
        ReturnHead(lh, l);
        write('(');
        while not IsTail(l) do begin
            Fetch(l, hhhh);
            MoveToNext(l);
            write(hhhh);
            if not IsTail(l) then begin
                write(',');
            end;
        end;
        writeln('  )');
    end;

    procedure ValidateList (lh: listHead; maxlen: longint);
        var
            item: listItem;
            count: integer;
            data: Handle;
    begin
        if lh = nil then begin
            DebugStr('ValidateList: lh = nil');
        end;
        count := 0;
        ReturnHead(lh, item);
        if item = nil then begin
            DebugStr('ValidateList: first item = nil');
        end;
        while not IsTail(item) do begin
            Fetch(item, data);
            MoveToNext(item);
            if item = nil then begin
                DebugStr('ValidateList: list item = nil');
            end;
            count := count + 1;
            if count > maxlen then begin
                DebugStr('ValidateList: List too long - probably bad');
                leave;
            end;
        end;
    end;

end.